home *** CD-ROM | disk | FTP | other *** search
/ SPACE 1 / SPACE - Library 1 - Volume 1.iso / program / 363 / xlisp20 / xlisp_c / xlbfun.c < prev    next >
Text File  |  1990-02-03  |  12KB  |  545 lines
  1. /* xlbfun.c - xlisp basic built-in functions */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* external variables */
  9. extern NODE *xlstack,*xlenv;
  10. extern NODE *s_car,*s_cdr,*s_get,*s_svalue,*s_splist;
  11. extern NODE *s_lambda,*s_macro;
  12. extern NODE *s_comma,*s_comat;
  13. extern char gsprefix[];
  14. extern int gsnumber;
  15.  
  16. /* forward declarations */
  17. FORWARD NODE *bquote1();
  18. FORWARD NODE *defun();
  19. FORWARD NODE *makesymbol();
  20.  
  21. /* xeval - the built-in function 'eval' */
  22. NODE *xeval(args)
  23.   NODE *args;
  24. {
  25.     NODE *oldstk,expr,*val;
  26.  
  27.     /* create a new stack frame */
  28.     oldstk = xlsave(&expr,NULL);
  29.  
  30.     /* get the expression to evaluate */
  31.     expr.n_ptr = xlarg(&args);
  32.     xllastarg(args);
  33.  
  34.     /* evaluate the expression */
  35.     val = xleval(expr.n_ptr);
  36.  
  37.     /* restore the previous stack frame */
  38.     xlstack = oldstk;
  39.  
  40.     /* return the expression evaluated */
  41.     return (val);
  42. }
  43.  
  44. /* xapply - the built-in function 'apply' */
  45. NODE *xapply(args)
  46.   NODE *args;
  47. {
  48.     NODE *oldstk,fun,arglist,*val;
  49.  
  50.     /* create a new stack frame */
  51.     oldstk = xlsave(&fun,&arglist,NULL);
  52.  
  53.     /* get the function and argument list */
  54.     fun.n_ptr = xlarg(&args);
  55.     arglist.n_ptr = xlmatch(LIST,&args);
  56.     xllastarg(args);
  57.  
  58.     /* if the function is a symbol, get its value */
  59.     if (symbolp(fun.n_ptr))
  60.     fun.n_ptr = xleval(fun.n_ptr);
  61.  
  62.     /* apply the function to the arguments */
  63.     val = xlapply(fun.n_ptr,arglist.n_ptr);
  64.  
  65.     /* restore the previous stack frame */
  66.     xlstack = oldstk;
  67.  
  68.     /* return the expression evaluated */
  69.     return (val);
  70. }
  71.  
  72. /* xfuncall - the built-in function 'funcall' */
  73. NODE *xfuncall(args)
  74.   NODE *args;
  75. {
  76.     NODE *oldstk,fun,arglist,*val;
  77.  
  78.     /* create a new stack frame */
  79.     oldstk = xlsave(&fun,&arglist,NULL);
  80.  
  81.     /* get the function and argument list */
  82.     fun.n_ptr = xlarg(&args);
  83.     arglist.n_ptr = args;
  84.  
  85.     /* if the function is a symbol, get its value */
  86.     if (symbolp(fun.n_ptr))
  87.     fun.n_ptr = xleval(fun.n_ptr);
  88.  
  89.     /* apply the function to the arguments */
  90.     val = xlapply(fun.n_ptr,arglist.n_ptr);
  91.  
  92.     /* restore the previous stack frame */
  93.     xlstack = oldstk;
  94.  
  95.     /* return the expression evaluated */
  96.     return (val);
  97. }
  98.  
  99. /* xquote - built-in function to quote an expression */
  100. NODE *xquote(args)
  101.   NODE *args;
  102. {
  103.     NODE *val;
  104.  
  105.     /* get the argument */
  106.     val = xlarg(&args);
  107.     xllastarg(args);
  108.  
  109.     /* return the quoted expression */
  110.     return (val);
  111. }
  112.  
  113. /* xfunction - built-in function to quote a function */
  114. NODE *xfunction(args)
  115.   NODE *args;
  116. {
  117.     NODE *val,*n;
  118.  
  119.     /* get the argument */
  120.     val = xlarg(&args);
  121.     xllastarg(args);
  122.  
  123.     /* create a closure for lambda expressions */
  124.     if (consp(val) && car(val) == s_lambda) {
  125.     n = newnode(LIST);
  126.     rplaca(n,val);
  127.     rplacd(n,xlenv);
  128.     val = n;
  129.     }
  130.  
  131.     /* otherwise, get the value of a symbol */
  132.     else if (symbolp(val))
  133.     val = xlgetvalue(val);
  134.  
  135.     /* otherwise, its an error */
  136.     else
  137.     xlerror("not a function",val);
  138.  
  139.     /* return the function */
  140.     return (val);
  141. }
  142.  
  143. /* xbquote - back quote function */
  144. NODE *xbquote(args)
  145.   NODE *args;
  146. {
  147.     NODE *oldstk,expr,*val;
  148.  
  149.     /* create a new stack frame */
  150.     oldstk = xlsave(&expr,NULL);
  151.  
  152.     /* get the expression */
  153.     expr.n_ptr = xlarg(&args);
  154.     xllastarg(args);
  155.  
  156.     /* fill in the template */
  157.     val = bquote1(expr.n_ptr);
  158.  
  159.     /* restore the previous stack frame */
  160.     xlstack = oldstk;
  161.  
  162.     /* return the result */
  163.     return (val);
  164. }
  165.  
  166. /* bquote1 - back quote helper function */
  167. LOCAL NODE *bquote1(expr)
  168.   NODE *expr;
  169. {
  170.     NODE *oldstk,val,list,*last,*new;
  171.  
  172.     /* handle atoms */
  173.     if (atom(expr))
  174.     val.n_ptr = expr;
  175.  
  176.     /* handle (comma <expr>) */
  177.     else if (car(expr) == s_comma) {
  178.     if (atom(cdr(expr)))
  179.         xlfail("bad comma expression");
  180.     val.n_ptr = xleval(car(cdr(expr)));
  181.     }
  182.  
  183.     /* handle ((comma-at <expr>) ... ) */
  184.     else if (consp(car(expr)) && car(car(expr)) == s_comat) {
  185.     oldstk = xlsave(&list,&val,NULL);
  186.     if (atom(cdr(car(expr))))
  187.         xlfail("bad comma-at expression");
  188.     list.n_ptr = xleval(car(cdr(car(expr))));
  189.     for (last = NIL; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr)) {
  190.         new = newnode(LIST);
  191.         rplaca(new,car(list.n_ptr));
  192.         if (last)
  193.         rplacd(last,new);
  194.         else
  195.         val.n_ptr = new;
  196.         last = new;
  197.     }
  198.     if (last)
  199.         rplacd(last,bquote1(cdr(expr)));
  200.     else
  201.         val.n_ptr = bquote1(cdr(expr));
  202.     xlstack = oldstk;
  203.     }
  204.  
  205.     /* handle any other list */
  206.     else {
  207.     oldstk = xlsave(&val,NULL);
  208.     val.n_ptr = newnode(LIST);
  209.     rplaca(val.n_ptr,bquote1(car(expr)));
  210.     rplacd(val.n_ptr,bquote1(cdr(expr)));
  211.     xlstack = oldstk;
  212.     }
  213.  
  214.     /* return the result */
  215.     return (val.n_ptr);
  216. }
  217.  
  218. /* xset - built-in function set */
  219. NODE *xset(args)
  220.   NODE *args;
  221. {
  222.     NODE *sym,*val;
  223.  
  224.     /* get the symbol and new value */
  225.     sym = xlmatch(SYM,&args);
  226.     val = xlarg(&args);
  227.     xllastarg(args);
  228.  
  229.     /* assign the symbol the value of argument 2 and the return value */
  230.     xlsetvalue(sym,val);
  231.  
  232.     /* return the result value */
  233.     return (val);
  234. }
  235.  
  236. /* xsetq - built-in function setq */
  237. NODE *xsetq(args)
  238.   NODE *args;
  239. {
  240.     NODE *oldstk,arg,sym,val;
  241.  
  242.     /* create a new stack frame */
  243.     oldstk = xlsave(&arg,&sym,&val,NULL);
  244.  
  245.     /* initialize */
  246.     arg.n_ptr = args;
  247.  
  248.     /* handle each pair of arguments */
  249.     while (arg.n_ptr) {
  250.     sym.n_ptr = xlmatch(SYM,&arg.n_ptr);
  251.     val.n_ptr = xlevarg(&arg.n_ptr);
  252.     xlsetvalue(sym.n_ptr,val.n_ptr);
  253.     }
  254.  
  255.     /* restore the previous stack frame */
  256.     xlstack = oldstk;
  257.  
  258.     /* return the result value */
  259.     return (val.n_ptr);
  260. }
  261.  
  262. /* xsetf - built-in function 'setf' */
  263. NODE *xsetf(args)
  264.   NODE *args;
  265. {
  266.     NODE *oldstk,arg,place,value;
  267.  
  268.     /* create a new stack frame */
  269.     oldstk = xlsave(&arg,&place,&value,NULL);
  270.  
  271.     /* initialize */
  272.     arg.n_ptr = args;
  273.  
  274.     /* handle each pair of arguments */
  275.     while (arg.n_ptr) {
  276.  
  277.     /* get place and value */
  278.     place.n_ptr = xlarg(&arg.n_ptr);
  279.     value.n_ptr = xlevarg(&arg.n_ptr);
  280.  
  281.     /* check the place form */
  282.     if (symbolp(place.n_ptr))
  283.         xlsetvalue(place.n_ptr,value.n_ptr);
  284.     else if (consp(place.n_ptr))
  285.         placeform(place.n_ptr,value.n_ptr);
  286.     else
  287.         xlfail("bad place form");
  288.     }
  289.  
  290.     /* restore the previous stack frame */
  291.     xlstack = oldstk;
  292.  
  293.     /* return the value */
  294.     return (value.n_ptr);
  295. }
  296.  
  297. /* placeform - handle a place form other than a symbol */
  298. LOCAL placeform(place,value)
  299.   NODE *place,*value;
  300. {
  301.     NODE *fun,*oldstk,arg1,arg2;
  302.  
  303.     /* check the function name */
  304.     if ((fun = xlmatch(SYM,&place)) == s_get) {
  305.     oldstk = xlsave(&arg1,&arg2,NULL);
  306.     arg1.n_ptr = xlevmatch(SYM,&place);
  307.     arg2.n_ptr = xlevmatch(SYM,&place);
  308.     xllastarg(place);
  309.     xlputprop(arg1.n_ptr,value,arg2.n_ptr);
  310.     xlstack = oldstk;
  311.     }
  312.     else if (fun == s_svalue || fun == s_splist) {
  313.     oldstk = xlsave(&arg1,NULL);
  314.     arg1.n_ptr = xlevmatch(SYM,&place);
  315.     xllastarg(place);
  316.     if (fun == s_svalue)
  317.         setvalue(arg1.n_ptr,value);
  318.     else
  319.         rplacd(arg1.n_ptr->n_symplist,value);
  320.     xlstack = oldstk;
  321.     }
  322.     else if (fun == s_car || fun == s_cdr) {
  323.     oldstk = xlsave(&arg1,NULL);
  324.     arg1.n_ptr = xlevmatch(LIST,&place);
  325.     xllastarg(place);
  326.     if (consp(arg1.n_ptr))
  327.         if (fun == s_car)
  328.         rplaca(arg1.n_ptr,value);
  329.         else
  330.         rplacd(arg1.n_ptr,value);
  331.     xlstack = oldstk;
  332.     }
  333.     else
  334.     xlfail("bad place form");
  335. }
  336.  
  337. /* xdefun - built-in function 'defun' */
  338. NODE *xdefun(args)
  339.   NODE *args;
  340. {
  341.     return (defun(args,s_lambda));
  342. }
  343.  
  344. /* xdefmacro - built-in function 'defmacro' */
  345. NODE *xdefmacro(args)
  346.   NODE *args;
  347. {
  348.     return (defun(args,s_macro));
  349. }
  350.  
  351. /* defun - internal function definition routine */
  352. LOCAL NODE *defun(args,type)
  353.   NODE *args,*type;
  354. {
  355.     NODE *oldstk,sym,fargs,closure,*fun;
  356.  
  357.     /* create a new stack frame */
  358.     oldstk = xlsave(&sym,&fargs,&closure,NULL);
  359.  
  360.     /* get the function symbol and formal argument list */
  361.     sym.n_ptr = xlmatch(SYM,&args);
  362.     fargs.n_ptr = xlmatch(LIST,&args);
  363.  
  364.     /* create a new function definition */
  365.     closure.n_ptr = newnode(LIST);
  366.     rplaca(closure.n_ptr,fun = newnode(LIST));
  367.     rplacd(closure.n_ptr,xlenv);
  368.     rplaca(fun,type);
  369.     rplacd(fun,newnode(LIST));
  370.     rplaca(cdr(fun),fargs.n_ptr);
  371.     rplacd(cdr(fun),args);
  372.  
  373.     /* make the symbol point to a new function definition */
  374.     xlsetvalue(sym.n_ptr,closure.n_ptr);
  375.  
  376.     /* restore the previous stack frame */
  377.     xlstack = oldstk;
  378.  
  379.     /* return the function symbol */
  380.     return (sym.n_ptr);
  381. }
  382.  
  383. /* xgensym - generate a symbol */
  384. NODE *xgensym(args)
  385.   NODE *args;
  386. {
  387.     char sym[STRMAX+1];
  388.     NODE *x;
  389.  
  390.     /* get the prefix or number */
  391.     if (args) {
  392.     x = xlarg(&args);
  393.     switch (ntype(x)) {
  394.     case STR:
  395.         strcpy(gsprefix,x->n_str);
  396.         break;
  397.     case INT:
  398.         gsnumber = x->n_int;
  399.         break;
  400.     default:
  401.         xlerror("bad argument type",x);
  402.     }
  403.     }
  404.     xllastarg(args);
  405.  
  406.     /* create the pname of the new symbol */
  407.     sprintf(sym,"%s%d",gsprefix,gsnumber++);
  408.  
  409.     /* make a symbol with this print name */
  410.     return (xlmakesym(sym,DYNAMIC));
  411. }
  412.  
  413. /* xmakesymbol - make a new uninterned symbol */
  414. NODE *xmakesymbol(args)
  415.   NODE *args;
  416. {
  417.     return (makesymbol(args,FALSE));
  418. }
  419.  
  420. /* xintern - make a new interned symbol */
  421. NODE *xintern(args)
  422.   NODE *args;
  423. {
  424.     return (makesymbol(args,TRUE));
  425. }
  426.  
  427. /* makesymbol - make a new symbol */
  428. LOCAL NODE *makesymbol(args,iflag)
  429.   NODE *args; int iflag;
  430. {
  431.     NODE *oldstk,pname,*val;
  432.     char *str;
  433.  
  434.     /* create a new stack frame */
  435.     oldstk = xlsave(&pname,NULL);
  436.  
  437.     /* get the print name of the symbol to intern */
  438.     pname.n_ptr = xlmatch(STR,&args);
  439.     xllastarg(args);
  440.  
  441.     /* make the symbol */
  442.     str = pname.n_ptr->n_str;
  443.     val = (iflag ? xlenter(str,DYNAMIC) : xlmakesym(str,DYNAMIC));
  444.  
  445.     /* restore the previous stack frame */
  446.     xlstack = oldstk;
  447.  
  448.     /* return the symbol */
  449.     return (val);
  450. }
  451.  
  452. /* xsymname - get the print name of a symbol */
  453. NODE *xsymname(args)
  454.   NODE *args;
  455. {
  456.     NODE *sym;
  457.  
  458.     /* get the symbol */
  459.     sym = xlmatch(SYM,&args);
  460.     xllastarg(args);
  461.  
  462.     /* return the print name */
  463.     return (car(sym->n_symplist));
  464. }
  465.  
  466. /* xsymvalue - get the value of a symbol */
  467. NODE *xsymvalue(args)
  468.   NODE *args;
  469. {
  470.     NODE *sym;
  471.  
  472.     /* get the symbol */
  473.     sym = xlmatch(SYM,&args);
  474.     xllastarg(args);
  475.  
  476.     /* return its value */
  477.     return (xlgetvalue(sym));
  478. }
  479.  
  480. /* xsymplist - get the property list of a symbol */
  481. NODE *xsymplist(args)
  482.   NODE *args;
  483. {
  484.     NODE *sym;
  485.  
  486.     /* get the symbol */
  487.     sym = xlmatch(SYM,&args);
  488.     xllastarg(args);
  489.  
  490.     /* return the property list */
  491.     return (cdr(sym->n_symplist));
  492. }
  493.  
  494. /* xget - get the value of a property */
  495. NODE *xget(args)
  496.   NODE *args;
  497. {
  498.     NODE *sym,*prp;
  499.  
  500.     /* get the symbol and property */
  501.     sym = xlmatch(SYM,&args);
  502.     prp = xlmatch(SYM,&args);
  503.     xllastarg(args);
  504.  
  505.     /* retrieve the property value */
  506.     return (xlgetprop(sym,prp));
  507. }
  508.  
  509. /* xputprop - set the value of a property */
  510. NODE *xputprop(args)
  511.   NODE *args;
  512. {
  513.     NODE *sym,*val,*prp;
  514.  
  515.     /* get the symbol and property */
  516.     sym = xlmatch(SYM,&args);
  517.     val = xlarg(&args);
  518.     prp = xlmatch(SYM,&args);
  519.     xllastarg(args);
  520.  
  521.     /* set the property value */
  522.     xlputprop(sym,val,prp);
  523.  
  524.     /* return the value */
  525.     return (val);
  526. }
  527.  
  528. /* xremprop - remove a property value from a property list */
  529. NODE *xremprop(args)
  530.   NODE *args;
  531. {
  532.     NODE *sym,*prp;
  533.  
  534.     /* get the symbol and property */
  535.     sym = xlmatch(SYM,&args);
  536.     prp = xlmatch(SYM,&args);
  537.     xllastarg(args);
  538.  
  539.     /* remove the property */
  540.     xlremprop(sym,prp);
  541.  
  542.     /* return nil */
  543.     return (NIL);
  544. }
  545. əəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəə